(in-package :lem/buffer/internal)

(defvar *inhibit-read-only* nil
  "If T, disables read-only for `buffer`.")

(defvar *inhibit-modification-hooks* nil
  "If T, prevents `before-change-functions` and `after-change-functions` from being called.")

(define-editor-variable before-change-functions '())
(define-editor-variable after-change-functions '())

(defun check-read-only-at-point (point n)
  (loop :for line := (point-line point) :then (line:line-next line)
        :for charpos := (point-charpos point) :then 0
        :do (unless line
              (return))
            (when (line:line-search-property-range line :read-only charpos (+ charpos n))
              (error 'read-only-error))
            (when (>= 0 (decf n (1+ (- (line:line-length line) charpos))))
              (return))))

(defun call-with-modify-buffer (point n function)
  (without-interrupts
    (let ((buffer (point-buffer point)))
      (unless *inhibit-read-only*
        (check-read-only-buffer buffer)
        (check-read-only-at-point point n))
      (prog1 (funcall function)
        (buffer-modify buffer)))))

(defmacro with-modify-buffer ((point n) &body body)
  `(call-with-modify-buffer ,point ,n (lambda () ,@body)))

(defun line-next-n (line n)
  (loop :repeat n
        :do (setf line (line:line-next line)))
  line)

(defun shift-markers (point offset-line offset-char)
  (cond ((and (= 0 offset-line)
              (< 0 offset-char))
         (let ((charpos (point-charpos point)))
           (dolist (p (line:line-points (point-line point)))
             (when (etypecase (point-kind p)
                     ((eql :left-inserting)
                      (<= charpos (point-charpos p)))
                     ((eql :right-inserting)
                      (< charpos (point-charpos p))))
               (incf (point-charpos p) offset-char)))))
        ((< 0 offset-line)
         (let ((linum (point-linum point))
               (charpos (point-charpos point))
               (line (line-next-n (point-line point) offset-line)))
           (dolist (p (buffer-points (point-buffer point)))
             (cond ((and (= linum (point-linum p))
                         (etypecase (point-kind p)
                           ((eql :left-inserting)
                            (<= charpos (point-charpos p)))
                           ((eql :right-inserting)
                            (< charpos (point-charpos p)))))
                    (incf (point-linum p) offset-line)
                    (decf (point-charpos p) charpos)
                    (incf (point-charpos p) offset-char)
                    (point-change-line p (+ linum offset-line) line))
                   ((< linum (point-linum p))
                    (incf (point-linum p) offset-line))))))
        ((and (= 0 offset-line)
              (> 0 offset-char))
         (let ((charpos (point-charpos point))
               (n (- offset-char)))
           (dolist (p (line:line-points (point-line point)))
             (when (< charpos (point-charpos p))
               (setf (point-charpos p)
                     (if (> charpos (- (point-charpos p) n))
                         charpos
                         (- (point-charpos p) n)))))))
        ((> 0 offset-line)
         (let ((linum (point-linum point))
               (charpos (point-charpos point))
               (line (point-line point))
               (offset-line (abs offset-line))
               (offset-char (abs offset-char)))
           (dolist (p (buffer-points (point-buffer point)))
             (when (or (< linum (point-linum p))
                       (and (= linum (point-linum p))
                            (<= charpos (point-charpos p))))
               (cond ((<= (- (point-linum p) offset-line)
                          linum)
                      (setf (point-charpos p)
                            (if (= (- (point-linum p) offset-line)
                                   linum)
                                (+ charpos (max 0 (- (point-charpos p) offset-char)))
                                charpos))
                      (point-change-line p linum line)
                      (setf (point-linum p) linum))
                     (t
                      (decf (point-linum p) offset-line)))))))))

(defgeneric insert-string/point (point string)
  (:method (point string)
    (let ((buffer (point-buffer point)))
      (with-modify-buffer (point 0)
        (loop :with start := 0
              :for pos := (position #\newline string :start start)
              :for line := (point-line point) :then (line:line-next line)
              :for charpos := (point-charpos point) :then 0
              :for offset-line :from 0
              :do (cond ((null pos)
                         (let ((substr (if (= start 0) string (subseq string start))))
                           (line:insert-string line substr charpos)
                           (shift-markers point offset-line (length substr)))
                         (return))
                        (t
                         (let ((substr (subseq string start pos)))
                           (line:insert-string line substr charpos)
                           (line:insert-newline line (+ charpos (length substr)))
                           (incf (buffer-nlines buffer))
                           (setf start (1+ pos))))))))
    string))

(defgeneric delete-char/point (point remaining-deletions)
  (:method (point remaining-deletions)
    (with-modify-buffer (point remaining-deletions)
      (with-output-to-string (killring-stream)
        (let ((charpos (point-charpos point))
              (line (point-line point))
              (offset-line 0))
          (loop :while (plusp remaining-deletions)
                :for eolp := (> remaining-deletions (- (line:line-length line) charpos))
                :do (cond
                      ((not eolp)
                       (let ((end (+ charpos remaining-deletions)))
                         (write-string (line:line-substring line :start charpos :end end)
                                       killring-stream)
                         (line:delete-region line :start charpos :end end))
                       (shift-markers point offset-line (- remaining-deletions))
                       (return))
                      ((null (line:line-next line))
                       (let ((offset (- charpos (line:line-length line))))
                         (write-string (line:line-substring line :start charpos) killring-stream)
                         (line:delete-region line :start charpos)
                         (shift-markers point offset-line offset))
                       (return))
                      (t
                       (decf (buffer-nlines (point-buffer point)))
                       (decf remaining-deletions (1+ (- (line:line-length line) charpos)))
                       (write-line (line:line-substring line :start charpos) killring-stream)
                       (line:merge-with-next-line line :start charpos)))
                    (decf offset-line)
                :finally (shift-markers point offset-line 0)))))))


(defun call-before-change-functions (point arg)
  (unless *inhibit-modification-hooks*
    (run-hooks (make-per-buffer-hook :var 'before-change-functions :buffer (point-buffer point))
               point arg)))

(defun call-after-change-functions (buffer start end old-len)
  (unless *inhibit-modification-hooks*
    (run-hooks (make-per-buffer-hook :var 'after-change-functions :buffer buffer)
               start end old-len)))

(defun need-to-call-after-change-functions-p (buffer)
  (and (not *inhibit-modification-hooks*)
       (or (variable-value 'after-change-functions :buffer buffer)
           (variable-value 'after-change-functions :global))))

(defun insert/after-change-function (point arg call-next-method)
  (if (need-to-call-after-change-functions-p (point-buffer point))
      (with-point ((start point))
        (prog1 (funcall call-next-method)
          (with-point ((end start))
            (character-offset end arg)
            (call-after-change-functions (point-buffer point) start end 0))))
      (funcall call-next-method)))

(defun delete/after-change-function (point call-next-method)
  (if (need-to-call-after-change-functions-p (point-buffer point))
      (let ((string (funcall call-next-method)))
        (with-point ((start point)
                     (end point))
          (call-after-change-functions (point-buffer point) start end (length string)))
        string)
      (funcall call-next-method)))

(defmethod insert-string/point :around (point string)
  (call-before-change-functions point string)
  (let ((buffer (point-buffer point)))
    (cond ((buffer-enable-undo-p buffer)
           (let ((position (position-at-point point)))
             (prog1 (insert/after-change-function point (length string) #'call-next-method)
               (let ((edit (make-edit :insert-string position string)))
                 (if (inhibit-undo-p)
                     (recompute-undo-position-offset buffer edit)
                     (push-undo buffer edit))))))
          (t
           (prog1 (insert/after-change-function point (length string) #'call-next-method)
             (when (inhibit-undo-p)
               (let ((edit (make-edit :insert-string (position-at-point point) string)))
                 (recompute-undo-position-offset buffer edit))))))))

(defmethod delete-char/point :around (point remaining-deletions)
  (call-before-change-functions point remaining-deletions)
  (let ((buffer (point-buffer point)))
    (cond ((buffer-enable-undo-p buffer)
           (let* ((position (position-at-point point))
                  (string (delete/after-change-function point #'call-next-method))
                  (edit (make-edit :delete-string position string)))
             (if (inhibit-undo-p)
                 (recompute-undo-position-offset buffer edit)
                 (push-undo buffer edit))
             string))
          (t
           (let ((string (delete/after-change-function point #'call-next-method)))
             (when (inhibit-undo-p)
               (let ((edit (make-edit :delete-string
                                      (position-at-point point)
                                      string)))
                 (recompute-undo-position-offset buffer edit)))
             string)))))
